unit ParserXML;

{
  Native Delphi XML Parser.
  Based on standard at http://www.saxproject.org/

  Copyright ?Keith Wood (kbwood@compuserve.com)
  Written 11 June, 2000.
  Updated 4 July, 2003.
}

interface

uses
  Classes, SysUtils, SAX, ParserBase;

const
  { DTD identifiers }
  NDataAttr  = 'NDATA';
  PublicAttr = 'PUBLIC';
  SystemAttr = 'SYSTEM';
  ValueAttr  = 'Value';

type
  { XML token types }
  TXMLToken = (toEOF, toElement, toComment, toInstruction, toText, toCData,
    toEntityRef, toDTD, toEntity, toNotation, toElementDecl, toAttrDecl);
  { XML tag types }
  TXMLTagType = (ttOpening, ttClosing, ttEmpty);

  { Parser for a generic XML document
    Assumes that all external entity substitutions and
    inclusions have already been done }
  TXMLParser = class(TCustomParser)
  private
    FAttributes: TStringList;
    FInDTD: Boolean;
    FTagType: TXMLTagType;
    FToken: TXMLToken;
  protected
    procedure Error(const Message: string); override;
    function ExtractTo(CharSet: SAXString; EOFError: string): SAXString;
      override;
  public
    constructor Create(Stream: TStream); override;
    destructor Destroy; override;
    property Line;
    property Column;
    property Token: TXMLToken read FToken write FToken;
    property TagType: TXMLTagType read FTagType write FTagType;
    property TokenString;
    property Attributes: TStringList read FAttributes;
    function NextToken: TXMLToken; reintroduce;
  end;

implementation

resourcestring
  { Error messages }
  InvalidToken        = 'Invalid token found - %s';
  Unfinished          = 'End of file encountered in %s';
  UnfinishedAttrDecl  = 'attribute declaration';
  UnfinishedCData     = 'character data';
  UnfinishedComment   = 'comment';
  UnfinishedDTD       = 'DTD';
  UnfinishedElemDecl  = 'element declaration';
  UnfinishedEntity    = 'entity';
  UnfinishedEntityRef = 'entity reference';
  UnfinishedInstr     = 'processing instruction';
  UnfinishedNotation  = 'notation';
  UnfinishedTag       = 'tag';

{ TXMLParser ------------------------------------------------------------------}

{ Initialisation }
constructor TXMLParser.Create(Stream: TStream);
var
  Signature: array [1..4] of Char;
begin
  inherited Create(Stream);
  FAttributes      := TStringList.Create;
  FInDTD           := False;
  FStream.Position := 0;
  { Determine encoding for this stream }
  FStream.Read(Signature, 4);
  if (Signature[1] = '<') and (Signature[2] = '?') and
      (Signature[3] = 'x') and (Signature[4] = 'm') then
  begin
    Encoding         := enUTF8;
    FStream.Position := 0;
  end
  else if (Signature[1] = #$FE) and (Signature[2] = #$FF) then
  begin
    Encoding         := enUTF16BE;
    FStream.Position := 2;
  end
  else if (Signature[1] = #0) and (Signature[2] = '<') and
      (Signature[3] = #0) and (Signature[4] = '?') then
  begin
    Encoding         := enUTF16BE;
    FStream.Position := 0;
  end
  else if (Signature[1] = #$FF) and (Signature[2] = #$FE) then
  begin
    Encoding         := enUTF16LE;
    FStream.Position := 2;
  end
  else if (Signature[1] = '<') and (Signature[2] = #0) and
      (Signature[3] = '?') and (Signature[4] = #0) then
  begin
    Encoding         := enUTF16LE;
    FStream.Position := 0;
  end
  else  { Default to UTF8 }
  begin
    Encoding         := enUTF8;
    FStream.Position := 0;
  end;
  NextToken;
end;

{ Release resources }
destructor TXMLParser.Destroy;
begin
  FAttributes.Free;
  inherited Destroy;
end;

{ Raise an error }
procedure TXMLParser.Error(const Message: string);
begin
  raise ESAXParseException.Create(Message, '', '', Line, Column);
end;

{ Compile characters up to (but excluding) one of a specified set }
function TXMLParser.ExtractTo(CharSet: SAXString; EOFError: string):
  SAXString;
begin
  if EOFError <> '' then
    EOFError := Format(Unfinished, [EOFError]);
  Result := inherited ExtractTo(CharSet, EOFError);
end;

{ Return the next token from the XML stream }
function TXMLParser.NextToken: TXMLToken;

  { Extract character data into internal string }
  procedure ExtractCData;
  begin
    while True do
    begin
      { Character data terminates with ']]>' }
      TokenString := TokenString + ExtractTo(']', UnfinishedCData);
      { Check for rest of terminator }
      if PeekString(']]>') then
        Break;
      TokenString := TokenString + NextChar;  { ']' }
    end;
  end;

  { Extract comment into internal string }
  procedure ExtractComment;
  begin
    while True do
    begin
      { Comment terminates with '-->' }
      TokenString := TokenString + ExtractTo('-', UnfinishedComment);
      { Check for rest of terminator }
      if PeekString('-->') then
        Break;
      TokenString := TokenString + NextChar;  { '-' }
    end;
  end;

  { Extract document type definition }
  procedure ExtractDTD;
  var
    Params: TStringList;
  begin
    Params := TStringList.Create;
    try
      try
        ExtractParameters(ExtractTo('[>', UnfinishedDTD), Params);
      except on EParserUnfinished do
        Error(Format(Unfinished, [UnfinishedDTD]));
      end;
      TokenString := Params[0];
      if Params.Count > 1 then
      begin
        if Params[1] = PublicAttr then
        begin
          Attributes.Values[PublicAttr] := StripQuotes(Params[2]);
          if Params.Count > 2 then
            Attributes.Values[SystemAttr] := StripQuotes(Params[3]);
        end
        else if Params[1] = SystemAttr then
          Attributes.Values[SystemAttr] := StripQuotes(Params[2]);
      end;
    finally
      Params.Free;
    end;

    if PeekChar = '[' then  { Internal declarations present? }
      NextChar;
    FInDTD := True;
  end;

  { Extract processing instruction into internal string }
  procedure ExtractInstruction;
  var
    Instr: SAXString;
  begin
    TokenString := ExtractTo(Blanks + '?', UnfinishedInstr);
    Instr := '';
    SkipBlanks;
    while not ((CurChar = '?') and (PeekChar = '>')) do
    begin;
      { Instruction terminates with '?>' }
      Instr := Instr + CurChar;
      Instr := Instr + ExtractTo('?', UnfinishedInstr);
      NextChar;  { '?' }
    end;
    NextChar;  { '>' }
    Attributes.Add(Instr);
  end;

  { Extract tag and associated attributes }
  procedure ExtractTag;
  var
    Index: Integer;
    Params: TStringList;
  begin
    Params := TStringList.Create;
    try
      try
        ExtractParameters(ExtractTo('>', UnfinishedTag), Params);
      except on EParserUnfinished do
        Error(Format(Unfinished, [UnfinishedTag]));
      end;
      if Params.Count = 0 then
        Error(Format(Unfinished, [UnfinishedTag]));

      NextChar;  { '>' }
      TokenString := Params[0];
      if Length(TokenString) > 0 then
      begin
        if TokenString[1] = '/' then
        begin
          TagType := ttClosing;
          TokenString := Copy(TokenString, 2, Length(TokenString) - 1);
        end;
        if TokenString[Length(TokenString)] = '/' then
        begin
          TagType := ttEmpty;
          TokenString := Copy(TokenString, 1, Length(TokenString) - 1);
        end;
      end;

      if Params[Params.Count - 1] = '/' then
      begin
        TagType := ttEmpty;
        Params.Delete(Params.Count - 1);
      end;
      Params.Delete(0);
      if Params.Count = 0 then
        Exit;

      if (Params.Count mod 2) <> 0 then
        Error(Format(Unfinished, [UnfinishedTag]));

      for Index := 0 to (Params.Count - 1) div 2 do
        Attributes.Values[Params[Index * 2]] :=
          StripQuotes(Params[Index * 2 + 1]);
    finally
      Params.Free;
    end;
  end;

  { Extract document type declarations }
  procedure ProcessDTD;

    { Extract element declaration }
    procedure ExtractElement;
    var
      Index: Integer;
      Params: TStringList;
      Model: SAXString;
    begin
      Token  := toElementDecl;
      Params := TStringList.Create;
      try
        try
          ExtractParameters(ExtractTo('>', UnfinishedElemDecl), Params);
        except on EParserUnfinished do
          Error(Format(Unfinished, [UnfinishedElemDecl]));
        end;
        NextChar;  { '>' }
        TokenString := Params[0];
        Model := '';
        for Index := 1 to Params.Count - 1 do
          Model := Model + StripQuotes(Params[Index]) + ' ';
        Attributes.Add(Copy(Model, 1, Length(Model) - 1));
      finally
        Params.Free;
      end;
    end;

    { Extract attribute declaration }
    procedure ExtractAttribute;
    var
      Params: TStringList;
    begin
      Token  := toAttrDecl;
      Params := TStringList.Create;
      try
        try
          ExtractParameters(ExtractTo('>', UnfinishedAttrDecl), Params);
        except on EParserUnfinished do
          Error(Format(Unfinished, [UnfinishedAttrDecl]));
        end;
        NextChar;  { '>' }
        TokenString := Params[0];
        Params.Delete(0);
        Attributes.Assign(Params);
      finally
        Params.Free;
      end;
    end;

    { Extract entity or notation parameters }
    procedure ExtractEntityOrNotation(XMLToken: TXMLToken; EOFError: string);
    var
      Index: Integer;
      Params: TStringList;
    begin
      Token  := XMLToken;
      Params := TStringList.Create;
      try
        try
          ExtractParameters(ExtractTo('>', EOFError), Params);
        except on EParserUnfinished do
          Error(Format(Unfinished, [EOFError]));
        end;
        NextChar;  { '>' }
        if Params[0] = '%' then  { Entity parameter }
        begin
          Params.Delete(0);
          Params[0] := '%' + Params[0];
        end;
        TokenString := Params[0];
        Index := 1;
        if (Index + 1 < Params.Count) and (Params[Index] = PublicAttr) then
        begin
          Attributes.Values[PublicAttr] := StripQuotes(Params[Index + 1]);
          Inc(Index, 2);
          if (Index < Params.Count) and (Params[Index] <> NDataAttr) then
          begin
            Attributes.Values[SystemAttr] := StripQuotes(Params[Index]);
            Inc(Index, 1);
          end
          else if XMLToken = toEntity then
            Error(Format(Unfinished, [EOFError]));
        end;
        if (Index + 1 < Params.Count) and (Params[Index] = SystemAttr) then
        begin
          Attributes.Values[SystemAttr] := StripQuotes(Params[Index + 1]);
          Inc(Index, 2);
        end;
        if (Index + 1 < Params.Count) and (Params[Index] = NDataAttr) then
        begin
          Attributes.Values[NDataAttr] := StripQuotes(Params[Index + 1]);
          Inc(Index, 2);
        end;
        if (Index < Params.Count) then
          Attributes.Values[ValueAttr] := StripQuotes(Params[Index]);
      finally
        Params.Free;
      end;
    end;

    { Ignore other DTD elements for the time being }
    procedure ExtractOther;
    begin
      ExtractTo('>', UnfinishedDTD);
      NextChar;  { '>' }
    end;

  begin
    while True do
    begin
      if Pos(CurChar, Blanks) > 0 then
        SkipBlanks;
      if CurChar = EOF then
        Error(Format(Unfinished, [UnfinishedDTD]))
      else if CurChar = '>' then
      begin
        Token   := toDTD;
        TagType := ttClosing;
        FInDTD  := False;
        Break;
      end;
      if CurChar = ']' then
      begin
        SkipBlanks;
        if CurChar <> '>' then
          Error(Format(Unfinished, [UnfinishedDTD]))
        else
        begin
          NextChar;  { '>' }
          Token   := toDTD;
          TagType := ttClosing;
          FInDTD  := False;
          Break;
        end;
      end
      else if CurChar = '<' then
      begin
        if PeekString('!ELEMENT') then
        begin
          ExtractElement;
          Break;
        end
        else if PeekString('!ATTLIST') then
        begin
          ExtractAttribute;
          Break;
        end
        else if PeekString('!ENTITY') then
        begin
          ExtractEntityOrNotation(toEntity, UnfinishedEntity);
          Break;
        end
        else if PeekString('!NOTATION') then
        begin
          ExtractEntityOrNotation(toNotation, UnfinishedNotation);
          Break;
        end
        else if PeekString('!--') then
        begin
          Token := toComment;
          ExtractComment;
          Break;
        end
        else if PeekString('?') then
        begin
          Token := toInstruction;
          ExtractInstruction;
          Break;
        end
        else
          ExtractOther;
      end
      else
        Error(Format(InvalidToken, [CurChar]));
    end;
  end;

begin
  TokenString := '';
  Attributes.Clear;
  NextChar;
  if FInDTD then
    ProcessDTD
  else
  begin
    if CurChar = EOF then
      Token := toEOF
    else if CurChar = '<' then
    begin  { Start tag - comments start with '!--',
             CDATA starts with '![CDATA[',
             definitions start with '!',
             processing instructions start with '?' }
      Token := toElement;
      TagType := ttOpening;
      if PeekString('!--') then
        Token := toComment
      else if PeekString('![CDATA[') then
        Token := toCData
      else if PeekString('!DOCTYPE') then
        Token := toDTD
      else if PeekString('?') then
        Token := toInstruction;

      case Token of
        toComment:     ExtractComment;
        toCData:       ExtractCData;
        toDTD:         ExtractDTD;
        toInstruction: ExtractInstruction;
        else           ExtractTag;
      end;
    end
    else if CurChar = '&' then
    begin  { Entity reference }
      Token       := toEntityRef;
      TokenString := ExtractTo(';', UnfinishedEntityRef);
      NextChar;  { ';' }
    end
    else
    begin  { Text }
      Token       := toText;
      TokenString := CurChar;
      TokenString := TokenString + ExtractTo('<&', '');
    end;
  end;
  Result := Token;
end;

end.
